home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 4 / The 640 Meg Shareware Studio CD-ROM Volume IV (Data Express)(1994).ISO / clang / forth030.zip / FORTH.INI < prev    next >
Text File  |  1993-06-29  |  14KB  |  424 lines
  1. ( FORTH.INI  Initialization file for FORTH/2        06/30/93 )
  2. ( Copyright <c> 1993  BLUE STAR SYSTEMS )
  3.  
  4. ( The following words from the Forth-83 standard are still missing:
  5.  
  6.   >BODY  CONVERT
  7.   D+  D<  DNEGATE  UM*  UM/MOD
  8.  
  9.   These are partially supported in the file BLOCKS.4TH:
  10.      BLK  BLOCK  BUFFER  FLUSH  LOAD  SAVE-BUFFERS  UPDATE
  11. )
  12.  
  13. HEX
  14. : ['] ( word-- lfa )  '  STATE @ IF  POSTPONE LITERAL  THEN ;  IMMEDIATE
  15.  
  16. : LFA ( lfa -- lfa )      ;
  17. : FFA ( lfa -- ffa ) 04 + ; ( Flag Field Address )
  18. : CFA ( lfa -- cfa ) 08 + ; ( Code Field Address )
  19. : NFA ( lfa -- nfa ) 0C + ; ( Name Field Address )
  20. : PFA ( lfa -- pfa ) 30 + ; ( Parameter Field Address )
  21. DECIMAL
  22.  
  23.  
  24. : greet ." This message came from the file 'FORTH.INI' " cr ;
  25. : CLS   27 emit ." [2J"  0 #OUT ! ;
  26.  
  27. ( Define the NON-STANDARD!!! " )
  28. : " POSTPONE 0" ; IMMEDIATE
  29.  
  30. VARIABLE CSP       ( Adds stack checking during compilation )
  31. : !CSP   SP@ CSP ! ;
  32. : ?CSP   SP@ CSP @ - IF ." Definition not finished " ABORT THEN ;
  33. : :            POSTPONE :  !CSP ;  IMMEDIATE
  34. : ;      ?CSP  POSTPONE ;  ;       IMMEDIATE
  35.  
  36. 1 CELLS CONSTANT CELL
  37.  
  38.  
  39. 32 CONSTANT BL
  40. : SPACE    BL EMIT ;
  41. : SPACES   0 MAX  1000 MIN  0 FOR  SPACE  NEXT ;
  42.  
  43. HEX
  44. : ?BRANCH,  C383038B , 0FC02304 , 84 C, 0 , ;
  45. : BRANCH,   E9 C, 0 , ;
  46.  
  47. : BEGIN     HERE ;             IMMEDIATE
  48. : WHILE     ?BRANCH,  HERE ;   IMMEDIATE
  49.  
  50. : REPEAT    SWAP   BRANCH,  HERE -  HERE CELL - !
  51.                        HERE OVER -  SWAP CELL - ! ;   IMMEDIATE
  52. : UNTIL           ?BRANCH,  HERE -  HERE CELL - ! ;   IMMEDIATE
  53. : AGAIN            BRANCH,  HERE -  HERE CELL - ! ;   IMMEDIATE
  54. : EXIT      R> DROP ;
  55.  
  56.  
  57. 0 CONSTANT CASE  IMMEDIATE
  58. : <OF>      OVER = IF  DROP 1  ELSE  0  THEN ;
  59. : OF        1+ >R  POSTPONE OVER   POSTPONE =
  60.                    POSTPONE IF     POSTPONE DROP  R> ; IMMEDIATE
  61. : ENDOF         >R POSTPONE ELSE                  R> ; IMMEDIATE
  62. : ENDCASE          POSTPONE DROP
  63.             0 FOR  POSTPONE THEN  NEXT ;               IMMEDIATE
  64.  
  65.  
  66. : LIT     R> DUP CELL + >R @ ;
  67. : ASCII   ( char-- b )  POSTPONE [CHAR] ;              IMMEDIATE
  68. : CONTROL ( char-- b )  BL WORD  CELL+ C@ 64 -
  69.                         State @ IF  POSTPONE LIT ,  THEN ; IMMEDIATE
  70. : CHAR    POSTPONE ASCII ; IMMEDIATE
  71.  
  72. DECIMAL
  73. : PAD   HERE 100 + ;      VARIABLE HLD
  74. : <#     ( n -- n )  PAD HLD ! ;
  75.  
  76. : #9     ( n -- )  9 OVER <  IF  7 +  THEN   ASCII 0 + ;
  77. : HOLD   ( char -- )  HLD @ -1 +  DUP HLD !  C! ;
  78.  
  79. : SIGN   0 < IF  ASCII - HOLD  THEN ;
  80.  
  81. : #   ( n -- n  ( one digit )  BASE @  /MOD ( U/MOD ) SWAP ABS #9 HOLD ;
  82. : #S  ( n -- 0  )  BEGIN  #   DUP  0 = UNTIL ;
  83.  
  84. : #>  ( n -- a l )  DROP   HLD @   PAD OVER -  ;
  85.  
  86. : .R  ( n length -- ) >R  DUP ABS  <#  #S  SWAP SIGN  #>
  87.                       R>  OVER - SPACES  TYPE ;
  88. : U.R ( n length -- ) >R           <#  #S  #>
  89.                       R>  OVER - SPACES  TYPE ;
  90. : .   0 .R  SPACE ;
  91. : ?   @ . ;
  92.  
  93. : ANSI. ( n -- )   ABS 0 .R ;
  94. : XY    ( x y -- ) 27 EMIT ." ["  ANSI.  59 EMIT  ANSI.  72 EMIT ;
  95.  
  96. : -ROT    ( n1 n2 n3 -- n3 n1 n2 ) ROT ROT ;
  97. : UNDER   ( n1 n2 -- n1 n1 n2 ) >R DUP R> ;
  98. : TUCK    ( n1 n2 -- n2 n1 n2 ) SWAP OVER ;
  99. : ALONG   ( n1 n2 -- n1+n2 n1 ) OVER + SWAP ;  ( good before DO loops )
  100.  
  101. : W-  CELL - ;   : 0>  0 > ;
  102. : 2+  2 + ;      : 2-  2 - ;
  103.  
  104. : TOGGLE ( n addr -- )  TUCK @ XOR SWAP ! ;
  105.  
  106. : TRUE  -1 ;                        : FALSE  0 ;
  107. : ON ( addr -- )  -1 SWAP ! ;       : OFF ( addr -- )  0 SWAP ! ;
  108.  
  109. : -TRAILING   ( addr n1 -- addr n2 )  2DUP + 1-  SWAP
  110.               0 FOR   DUP C@  BL > IF  LEAVE  ELSE  1-  THEN
  111.                 NEXT  1+  OVER - ;
  112. : 0-Terminate ( addr -- )  @+ + 0 SWAP C! ;
  113. : 0"COUNT ( addr -- addr len )  DUP    BEGIN
  114.                       DUP C@ WHILE  1+ REPEAT  OVER - ;
  115.  
  116.  
  117. : ".  ( addr -- )  @+ TYPE ;      (  ".  prints a counted       string )
  118. : 0". ( addr -- )  0"COUNT TYPE ; ( 0".  prints a 0-terminated string. )
  119.  
  120.  
  121. 4 CONSTANT StrPadSize                   ( All strings are padded with 4 0's  )
  122. : "->0"    ( addr1 -- addr2 ) CELL + ;  ( Convert counted string to 0-end string )
  123. : ",       @ CELL+ StrPadSize + ALLOT ; ( Compile string into dictionary   )
  124.  
  125. : <">      R> DUP  @+ +  StrPadSize +  >R     ;
  126. : <.(>     R> DUP  @+ +  StrPadSize +  >R  ". ;
  127. : <ABORT"> R> DUP  @+ +  StrPadSize +  >R  SWAP  IF  ".  ABORT CR
  128.            ELSE  DROP  THEN ;
  129.  
  130. \ HUH? (MAW - I don't get this one!?!?!?!? )
  131. \
  132. \  : 0"       State @ IF  POSTPONE <0">   THEN
  133. \             ASCII " WORD
  134. \             State @ IF  ",  ELSE "->0" THEN ; IMMEDIATE
  135. \
  136. \ : "        State @ IF  POSTPONE <">    THEN
  137. \            ASCII " WORD
  138. \            State @ IF  ",             THEN ; IMMEDIATE
  139. \
  140. \ : ."       State @ IF  POSTPONE ."    ELSE
  141. \            ASCII " WORD  ".           THEN ; IMMEDIATE
  142. \
  143. \ : .(       State @ IF  POSTPONE <.(>   THEN
  144. \            ASCII ) WORD
  145. \            State @ IF  ",  ELSE  ".   THEN ; IMMEDIATE
  146. \
  147. \ : S"       POSTPONE "  POSTPONE @+ ;
  148. \
  149. \ : ,"       POSTPONE "  HERE @ CELL+ ALLOT ;
  150. \
  151.  
  152. : ABORT"   ?COMPILE    POSTPONE <ABORT"> 
  153.            ASCII " WORD  ", ; IMMEDIATE
  154.  
  155. VARIABLE FENCE
  156. : +VLink      CELL+ ;
  157. : +NextVoc  2 CELLS + ;
  158. : FORGET ( name-- )     \ Forgets across vocabularies
  159.      '  FENCE @ over U< IF
  160.        Context ContextSize CELLS along DO
  161.            dup  I @  u< IF  0 I !  THEN  CELL +LOOP
  162.        Context  Context ContextSize CELLS along do
  163.            I @ IF  I @  0 I !  over !  CELL+  THEN   CELL +LOOP  drop
  164.        >R  I  Current @ +VLink @ U< IF  POSTPONE Forth  THEN
  165.        VOC-LINK @
  166.        BEGIN  I OVER U< WHILE  +NextVoc @  REPEAT
  167.        DUP VOC-LINK !
  168.        BEGIN  DUP +VLink
  169.            BEGIN  @  dup I u< UNTIL
  170.            over +VLink !  +NextVoc @  ?DUP 0=
  171.        UNTIL  R> DP!
  172.     ELSE
  173.       ." Can't forget before FENCE! " cr
  174.     THEN ;
  175.  
  176. ' FORGET FENCE !   \ Set up the fence
  177.  
  178.  
  179.  
  180. : 2CONSTANT  CREATE  SWAP , ,  DOES>  DUP @ SWAP CELL+ @ ;
  181. : 2VARIABLE  VARIABLE  CELL ALLOT ;
  182.  
  183. : ERASE  ( addr len -- )  0 FILL ;  \ Fill memory with 0's
  184.  
  185. : TYPE     dup 20000 > ABORT" Tried to TYPE over 20000 characters" TYPE ;
  186.  
  187. \ "MOVE  moves a counted string to another address
  188.  
  189. : "MOVE  ( counted_string_address dest_address -- )
  190.          OVER @  CELL+  CMOVE ;
  191.  
  192.  
  193. \ MOVE>"  copies addr,len to be a counted string at dest_addr
  194.  
  195. : MOVE>"  ( addr len dest_addr -- ) 2dup !
  196.                                     CELL+ swap cmove ;
  197.  
  198.  
  199. \ "CAT   conCATenate string1 to the end of string2
  200.  
  201. : "CAT   ( counted_string_addr1  counted_string_dest_addr2 -- )
  202.          2DUP  @+ +  SWAP @+ ROT SWAP CMOVE
  203.          SWAP @  SWAP +! ;
  204.  
  205.  
  206. : "CONSTANT  ( addr <word>-- Does: -- addr ) HERE 53 + "MOVE
  207.              CREATE  HERE ",  DOES> ;
  208.  
  209. : CALL"  ( <string><name>-- Does: -- addr ) ASCII " WORD  "CONSTANT ;
  210.  
  211. \ CALL" Bill Clinton" President  ...   President ".
  212.  
  213.  
  214. : INTEGER  ( -- )   CREATE  HERE  0 ,
  215.                             %TO @ IF  <TODOES>  ELSE  DROP  THEN
  216.                     DOES>   <TODOES> ;
  217.  
  218. : INTARRAY ( size ) CREATE  CELLS  HERE  OVER ALLOT  DUP ROT 0 FILL
  219.                             %TO @ IF  SWAP CELLS + <TODOES>  THEN
  220.                     DOES>  SWAP CELLS +  <TODOES> ;
  221.  
  222. \ STRING TO variables:  " XYZ123" TO String1  ...   String1 ".
  223.  
  224. variable StringSize  255 StringSize !    \ Size of STRING's to be created
  225. variable TempString  StringSize @ ALLOT  \ To move string out of way of CREATE
  226.  
  227. : <"TODOES>  ( -- addr  ;  addr TO --   ;  addr +TO --  )
  228.              %TO @    IF
  229.              %TO @ 0> IF  "MOVE  ELSE  "CAT  THEN  0 %TO !  THEN ;
  230.  
  231. : STRING   %TO @ IF  TempString "MOVE  TempString  THEN
  232.            CREATE  HERE  StringSize @ CELL+ ALLOT  DUP StringSize @ CELL+ 0 FILL
  233.                    %TO @ IF  <"TODOES>  ELSE  DROP  THEN
  234.            DOES>   <"TODOES> ;
  235.  
  236.  
  237. : TONE ( frequency duration -- ) SWAP SYS$BEEP SYSCALL  3 DROPS ;
  238. ( frequency in cycles/second, duration in milliseconds, 1/1000 of a second )
  239.  
  240. : BEEP  3000 60 TONE ;
  241.  
  242. HEX
  243.  
  244. Variable   Handle
  245. Variable   ActionTaken
  246. Variable   BytesTransferred
  247. Variable   BufferArea
  248. Variable   BufferLength
  249. Variable   LineSource
  250. Variable   LineLength
  251.  
  252. 0   Constant    EABUF
  253. 42  Constant    OpenMode
  254. 11  Constant    OpenFlag
  255. 0   Constant    FileAttribute
  256. 0   Constant    FileSize
  257.  
  258. : Source LineLength @ LineSource @ ;
  259.  
  260. : Open ( name -- handle ) >R EABUF OpenMode OpenFlag FileAttribute
  261.     FileSize ActionTaken Handle R> sys$open syscall
  262.     9 Drops  handle @ ;
  263.  
  264. \ : Close ( handle -- ) Sys$Close SysCall 2drop ;
  265.  
  266. : FWrite ( handle address length )
  267.   BufferLength !
  268.   BufferArea !
  269.   Handle !
  270.   BytesTransferred BufferLength @ BufferArea @ Handle @ sys$write syscall
  271.   5 drops ;
  272.  
  273. : FRead ( handle address buffersize --  )
  274.   BufferLength !
  275.   BufferArea !
  276.   Handle !
  277.   BytesTransferred BufferLength @ BufferArea @ Handle @ sys$read syscall
  278.   5 drops ;
  279.  
  280. : EOF?  ( -- f ) BytesTransferred @ 0= ;  \ True if at end of file
  281.  
  282. Variable FilePtr
  283. : FSeek   ( ptr handle -- f ) >R  FilePtr  0  ROT   R> SYS$SEEK SYSCALL
  284.                               >R  4 Drops  R> ;
  285.  
  286. : Readln ( handle -- addr len ) DUP >R  FBuffer 100 FRead
  287.          FBuffer  begin
  288.                      dup c@  dup 0A =  swap 0= OR  NOT while
  289.               1+  repeat  1- ( subtract off 0Dh from length )
  290.          FBuffer tuck -  dup FilePtr @ + 2+ R> FSeek  ABORT" Seek failed"
  291.  
  292.          2dup LineSource ! LineLength ! ;
  293.  
  294.  
  295. : Fibinacci ( n -- fib[n] )
  296.   dup 2 <= if drop 1 else dup 1 - recurse swap 2 - recurse + then ;
  297.  
  298.  
  299. Variable ResultCodes 4 allot
  300.  
  301. Variable Arguments 256 Allot
  302.  
  303. : Args  ( string -- ) Arguments "MOVE  Arguments 0-Terminate ;
  304. : Args" ( args-- )  State @ IF  COMPILE "  Compile Args  ELSE
  305.                                   ASCII " WORD  Args     THEN ; IMMEDIATE
  306.  
  307. : Shell ( name -- ) Arguments CELL+ @ if
  308.                         Arguments CELL+  over @  over + 1+ Arguments @ 1+ cmove>
  309.                         dup @  Arguments + CELL+ 0 swap c!
  310.                         dup    Arguments "MOVE then     "->0"
  311.                     ResultCodes 0 Arguments CELL+ 0 0 0 sys$execpgm syscall
  312.                     8 drops     0 Arguments CELL+ ! ;
  313.  
  314. : Shell"   State @ IF   POSTPONE "  Compile Shell  ELSE
  315.                            ASCII " WORD  shell     THEN ;  IMMEDIATE
  316.  
  317. : CommandShell ( shell's to C:\OS2\CMD.EXE ) " C:\OS2\CMD.EXE" shell ;
  318.  
  319. : dir          " /C DIR " Arguments "MOVE  bl word Arguments "CAT
  320.                Arguments 0-terminate  CommandShell ;  
  321. \ Example: dir *.4th
  322.  
  323. : DoShell " c:\os2\cmd.exe" resultcodes 0 0 0 0 0 sys$execpgm syscall 8 drops ;
  324.  
  325. DECIMAL
  326.  
  327. \ ?PAGE gives scrolling control to pause at the end of each screen
  328.  
  329. VARIABLE L/P  23 L/P !  ( Lines per Page )
  330. : 0PAGE  0 LINE# ! ;
  331. : ?PAGE  ( -- f )  1 LINE# +!  LINE# @ L/P @ > IF
  332.             CR  ." Space to continue, Enter to advance 1 line... "
  333.             KEY  255 AND  DUP 32 OR 113 = if  DROP  CR True  else
  334.                                      31 > if  0PAGE  then   False then
  335.             13 EMIT  46 SPACES  13 EMIT  ELSE  CR  False  THEN ;
  336.  
  337.  
  338. \ Use DUMP to examine an area of memory 
  339. DECIMAL
  340. : HEX.     DUP 9 > IF  55  ELSE  48  THEN  + EMIT ;
  341. : SAFEMIT  DUP 14 < OVER 6 > AND IF DROP BL THEN  EMIT ;
  342. : ASCII. ( addr -- )  16 0 DO  DUP C@ SAFEMIT  1 + LOOP  DROP ;
  343. : BYTE.    DUP 16 / HEX. 16 MOD HEX. SPACE ;
  344. : LINE.  ( addr -- ) 16 0 DO  DUP C@ BYTE.  1 +
  345.                  DUP 16 MOD 0 = IF  SPACE  THEN  LOOP DROP ;
  346. : DUMP   ( addr len -- ) BASE @ >R HEX  0PAGE CR
  347.          16 / 1 +  0 DO
  348.                DUP .  SPACE  DUP LINE.  3 SPACES DUP ASCII.  
  349.                ?PAGE IF  LEAVE  THEN
  350.          16 + LOOP R> BASE !  DROP ;
  351.  
  352.  
  353. \ MORE lists the contents of a file.   Example:  0" FORTH.INI" MORE
  354. : MORE ( name -- )  Open  0PAGE  CR  0 FilePtr !
  355.         begin   dup readln type  ?PAGE
  356.                 eof?  OR  until
  357.         Close ;
  358.  
  359. : MORE" ( name-- ) ASCII " WORD  CELL+ MORE ;
  360. \ Example: MORE" FORTH.INI"
  361.  
  362. create WordStr 31 allot   variable ViewPtr
  363. : VIEW ( word-- )  0" FORTH2.DOC" Open  CR  0 FilePtr !
  364.         BL Word  WordStr "MOVE
  365.         ViewPtr @ IF  ViewPtr @ over FSEEK ABORT" Seek failed"
  366.         ELSE
  367.           870 0 do  dup readln 2drop       \ Skip 880 lines
  368.                     eof? if  leave then
  369.           loop      eof? if  exit  then
  370.           begin   dup readln               \ Look for vocabulary listing
  371.                   " --Begin--"  =STRING  eof? or  until
  372.           eof? ABORT" Did not find vocabulary listing"
  373.           FilePtr @ ViewPtr !              \ Save beginning location
  374.         THEN
  375.         begin   dup readln                 \ Look for word
  376.                2dup WordStr @ min  WordStr =STRING NOT
  377.                eof? NOT and  while  2drop
  378.         repeat
  379.         eof? ABORT" Did not find word"
  380.         TYPE  CR  close ;
  381. \ VIEW  shows information about Forth words:  VIEW ECHO
  382.  
  383.  
  384. \ User ECHO to turn on/off echoing of files while they are being loaded.
  385.  
  386. VARIABLE Echo  \ Echo ON  --> Echo file being loaded to screen
  387.                \ Echo OFF --> Do not echo
  388.  
  389. TRUE ECHO !
  390.  
  391. : INCLUDE ( name -- ) OPEN >R                \ Load a Forth source file
  392.         TIB @  FilePtr @  LINE# @  Echo @    \ save & restore TIB
  393.         0 FilePtr !  0 LINE# !
  394.         begin  i readln   1 LINE# +!
  395.            EOF? not while
  396.                dup if  
  397.                   Echo @ if cr 2dup type then
  398.                   1+ #TIB !  TIB !  INTERPRET
  399.                else  2drop  then
  400.            repeat    2drop
  401.         Echo !  LINE# !  FilePtr !  TIB !
  402.         R> Close ;
  403.  
  404. : INCLUDE"  ( filename-- ) ASCII " WORD CELL+ INCLUDE ; \ INCLUDE" STRUCT.4TH"
  405.  
  406.  
  407. : VOCABULARY ( voc_name-- )
  408.              CREATE  HERE  0 ,  0 ,  VOC-LINK @ ,  VOC-LINK !  IMMEDIATE
  409.              DOES>   <VOCABULARY> ;
  410.  
  411. : DEFINITIONS ( -- )  CONTEXT @ CURRENT ! ;
  412. : ONLY ( -- ) CONTEXT @  CONTEXT ContextSize CELLS 0 FILL  CONTEXT !
  413.               DEFINITIONS ;
  414.  
  415. ( Add any files you want to load at start-up time here )
  416.  
  417. ( include" struct.4th"   )
  418. (  include" threads.4th"  )
  419. ( include" locals.4th"   )
  420. ( include" startup.4th"  )
  421. (  include" mike.4th"     )
  422.  
  423. greet
  424.